home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / guile-ii.src / guile-ii / guile-src / slib / process.scm < prev    next >
Encoding:
Text File  |  1995-04-23  |  2.1 KB  |  78 lines
  1. ;;;; "process.scm",  Multi-Processing for Scheme
  2. ;;; Copyright (C) 1992, 1993 Aubrey Jaffer.
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. (require 'full-continuation)
  21. (require 'queue)
  22.  
  23. (define (number-of-runable-processes) (queue-length process:queue))
  24.  
  25. (define (add-process! thunk1)
  26.   (cond ((procedure? thunk1)
  27.      (defer-ints)
  28.      (enqueue! process:queue thunk1)
  29.      (allow-ints))
  30.     (else (slib:error "add-process!: wrong type argument " thunk1))))
  31.  
  32. (define (push-process! thunk1)
  33.   (cond ((procedure? thunk1)
  34.      (defer-ints)
  35.      (queue-push! process:queue thunk1)
  36.      (allow-ints))
  37.     (else (slib:error "add-process!: wrong type argument " thunk1))))
  38.  
  39. (define (process:schedule!)
  40.   (defer-ints)
  41.   (cond ((queue-empty? process:queue) (allow-ints)
  42.                       'still-running)
  43.     (else (call-with-current-continuation
  44.            (lambda (cont)
  45.          (enqueue! process:queue cont)
  46.          (let ((proc (dequeue! process:queue)))
  47.            (allow-ints)
  48.            (proc 'run))
  49.          (kill-process!))))))
  50.  
  51. (define (kill-process!)
  52.   (defer-ints)
  53.   (cond ((queue-empty? process:queue) (allow-ints)
  54.                       (slib:exit))
  55.     (else (let ((proc (dequeue! process:queue)))
  56.         (allow-ints)
  57.         (proc 'run))
  58.           (kill-process!))))
  59.  
  60. (define ints-disabled #f)
  61. (define alarm-deferred #f)
  62.  
  63. (define (defer-ints) (set! ints-disabled #t))
  64.  
  65. (define (allow-ints)
  66.   (set! ints-disabled #f)
  67.   (cond (alarm-deferred
  68.       (set! alarm-deferred #f)
  69.       (alarm-interrupt))))
  70.  
  71. ;;; Make THE process queue.
  72. (define process:queue (make-queue))
  73.  
  74. (define (alarm-interrupt)
  75.   (alarm 1)
  76.   (if ints-disabled (set! alarm-deferred #t)
  77.       (process:schedule!)))
  78.